home *** CD-ROM | disk | FTP | other *** search
/ Trading on the Edge / Trading On The Edge - CD-ROM Toolkit (Wayzata Technology)(2031)(1994).bin / pc / mac_file / vendor_d / ga_softw / ooga / utility.lis < prev   
Lisp/Scheme  |  1991-02-03  |  19KB  |  604 lines
  1. ;;; -*- Mode:Lisp; Package:OOGA; Base:10; Syntax:COMMON-LISP -*-
  2. #||
  3.             RESTRICTED RIGHTS LEGEND
  4.                     
  5.  Use, duplication, or disclosure by the Government is subject to
  6.  restrictions as set forth in subdivision (b)(3)(ii) of the Rights in
  7.  Technical Data and Computer Software Clause at 52.227-7013 of the DOD
  8.  FAR Supplement.
  9.                     
  10.                 TSP (The Software Partnership)
  11.                 P.O. Box 991
  12.                 Melrose, MA 02176
  13.                     
  14.       Copyright 1990 by Lawrence Davis and Daniel Cerys, all rights reserved.
  15. ||#
  16.  
  17. (in-package :ooga)
  18.  
  19. ;This file contains utilities for the genetic algorithm system.
  20.  
  21. ;**************************************************
  22.  
  23. ;    ROUTINES THAT GET ITEMS FROM LISTS BY THEIR ASSOCIATED WEIGHTS
  24.  
  25.  
  26. (defun MAKE-WEIGHTED-LIST (elements weights)
  27.   "Produce a list of outputs based on the input weights.
  28. Elements are returned in order of decreasing weights."
  29.   (let ((element-weight-pairs (mapcar #'cons elements weights)))
  30.     (mapcar #'car (sort element-weight-pairs #'> :key #'cdr))))
  31.  
  32.  
  33. (defun GET-ASSOCIATED-TOTAL-LIST-ELEMENT (element-list weight-list total)
  34.   "Get the element and its place whose weight corresponds to the running total"
  35.   (do ((elements element-list (cdr elements))
  36.        (weights weight-list (cdr weights))
  37.        (n 0 (1+ n)))
  38.       ((null elements))
  39.     (if (>= (car weights) total)
  40.     (return (values (car elements) n))
  41.     (setf total (- total (car weights))))))
  42.  
  43.  
  44. (defun GET-ASSOCIATED-LINKED-LIST-ELEMENT (first-element weight-list total)
  45.   "Get the element and its place whose weight corresponds to the running total"
  46.   (loop for element = first-element then (successor element)
  47.     for weight in weight-list
  48.     for running-total = (car weight-list) then (+ weight running-total)
  49.     for n from 0
  50.     do (if (>= running-total total)
  51.            (return (values element n)))))
  52.  
  53.  
  54. (defun GET-ASSOCIATED-RUNNING-TOTAL-ELEMENT (element-list weight-list total)
  55.   "Get the element and its place whose weight is less than the precompiled running total"
  56.   (do ((elements element-list (cdr elements))
  57.        (weights weight-list (cdr weights))
  58.        (n 0 (1+ n)))
  59.       ((null elements))
  60.     (if (>= (car weights) total)
  61.     (return (values (car elements) n)))))
  62.  
  63.  
  64.  
  65. ;**************************************************
  66.  
  67. ;    RANDOM NUMBER GENERATOR ROUTINES
  68.  
  69. ;;; We want to provide a general portable interface for generating random numbers.
  70. ;;; Ideally, users should be given the option of whether different runs
  71. ;;; of these random numbers should have identical or guaranteed
  72. ;;; different random sequences.  (I.E.  You may want to be able to
  73. ;;; reproduce previous results with the same random numbers).
  74. ;;; If reproducibility is important, than so is portability of a random
  75. ;;; number generator (which we will hopefully provide).
  76.  
  77.  
  78. #+ignore  ;; We no longer shadow Random because of the problems it was causing in some implementations
  79. (defun RANDOM (high &optional state)
  80.   "The random number function we call in all places.  Redefine this if
  81. you want some special behavior of the random number generator."
  82.   (if state 
  83.       (lisp:random high state)
  84.       (lisp:random high)
  85.       ))
  86.  
  87. ;;;
  88. ;;; The following normal generators may be useful for some applications...
  89. ;;; 
  90.  
  91. ;;; The function Normal-Random-Number comes with the following copyright:
  92. ;;; ------------------------------------------------------------
  93. ;;;  (c) Copyright Gerald Roylance 1983, 1984, 1987
  94. ;;;      All Rights Reserved.
  95. ;;;  This file may be distributed noncommercially provided
  96. ;;;  that this notice is not removed.
  97. ;;; ------------------------------------------------------------
  98.  
  99. ;;;; Normal Random Number
  100.  
  101. ;;; -- Ratio of Uniform Deviates Method
  102.  
  103. ;;;   f(x) = (exp (-x*x/2))
  104. ;;;           the / (sqrt (* 2 pi))  doesn't matter
  105. ;;;   mean = 0
  106. ;;;   vari = 1
  107. ;;; u-bound : 0 <= u <= 1
  108. ;;; v-bound :      u <= sqrt(exp(-(v/u)**2/2)
  109. ;;;                   = exp(-v**2 / (4 u**2))
  110. ;;;         : log(u) <= -v**2 / (4 u**2)
  111. ;;;         : 4 u**2 log(u) <= -v**2
  112. ;;;         : v**2   <= -4 u**2 log(u)
  113. ;;;    rhs is max when d(rhs)/du = 0
  114. ;;;        -4 (2u log(u) + u) = 0
  115. ;;;        -4u (2 log(u) + 1) = 0
  116. ;;;          u = {0, exp(-0.5)}
  117. ;;;  therefore the v-bound is
  118. ;;;         : v**2   <= -4 u**2 log(u) = -4 exp(-1) (-0.5)
  119. ;;;                                    =  2 exp(-1)
  120. ;;;    -sqrt(2)exp(-0.5) <= v <= +sqrt(2)exp(-0.5)
  121. ;;;
  122. ;;; P{acceptance} = 0.73057
  123.  
  124. (defun NORMAL-RANDOM-NUMBER ()
  125.   "Returns a normally distributed deviate with 0 mean and unit variance."
  126.   (flet ((uniform-random-number () (random 1.0)))
  127.     (do ((u 0.0)
  128.      (v 0.0))
  129.     ((progn
  130.        (setq u (uniform-random-number)    ; U is bounded (0 1)
  131.          v (* 2.0 (sqrt 2.0) (exp -0.5)    ; V is bounded (-MAX MAX)
  132.               (- (uniform-random-number) 0.5)))
  133.        (<= (* v v) (* -4.0 u u (log u))))    ; < should be <=
  134.      (/ v u))
  135.       (declare (float u v)))))
  136.  
  137. ;;; The following is translated from Numerical Recipes
  138. ;;; It is about twice as fast, mostly because it only has to do work every other call.
  139. (let (gset
  140.       (iset nil))
  141.   (defun GASDEV ()
  142.     (cond ((null iset)
  143.        (loop for v1 = (1- (* 2 (random 1.0)))
  144.          and v2 = (1- (* 2 (random 1.0)))
  145.          for r = (+ (* v1 v1) (* v2 v2))
  146.          until (< r 1)
  147.          finally (let ((fac (sqrt (/ (* -2.0 (log r)) r))))
  148.                (setf gset (* v1 fac)
  149.                  iset t)
  150.                (return (* v2 fac)))))
  151.       (t (setf iset nil)
  152.          (values gset)))))
  153.  
  154.  
  155.  
  156. ;**************************************************
  157.  
  158. ;    UTILITY ROUTINES
  159.  
  160.  
  161. (defun ROUND-TO (number place)
  162.   "Round to the place after the decimal.  Place should
  163.    be a power of 10.  Ex:  (round-to 5.45678 1000) ==> 5.457"
  164.   (/ (round (* number place)) (float place)))
  165.  
  166.  
  167. (defun CREATE-RANDOM-BIT-STRING (length)
  168.   (loop for x below length
  169.     collect (random 2)))
  170.  
  171.  
  172. (defun EVEN-MULTIPLE (number base)
  173.   "Is number even multiple of base?"
  174.   (= number (* base (floor (/ number base)))))
  175.  
  176.  
  177. (defun NEXT-EVEN-INTERVAL (current-number interval)
  178.   "Return next multiple of interval.  
  179.    Assumption is that both current-number and interval are integers."
  180.   (+ (* interval (floor (/ current-number interval)))
  181.      interval))
  182.  
  183.  
  184. (defun CONVERT-BIT-STRING-TO-INTEGER (bit-string)
  185.   "Convert the bit string to an integer using powers of 2"
  186.   (loop for bit in (reverse (copy-list bit-string))
  187.     for 2-power = 1 then (+ 2-power 2-power)
  188.     summing (if (= bit 1) 2-power 0)))
  189.  
  190.  
  191. (defun BIGGEST-2-DIVISOR (integer)
  192.   "Find the larger power of 2 in the integer"
  193.   (loop for 2-power = 1 then (+ 2-power 2-power)
  194.     until (> 2-power integer)
  195.     finally (return (/ 2-power 2))))
  196.  
  197.  
  198. (defun CONVERT-INTEGER-TO-BIT-STRING (integer)
  199.   "Convert the integer to a bit string"
  200.   (if (< integer 1) '(0)
  201.   (loop with number = integer
  202.     for 2-power = (biggest-2-divisor integer)
  203.         then (/ 2-power 2)
  204.     until (< 2-power 1)
  205.     collect (if (< number 2-power) 0
  206.             (and (setf number (- number 2-power)) 1))
  207.     into bits
  208.     finally (return bits))))
  209.  
  210.  
  211. (defun ONE-POINT-CROSSOVER (list1 list2)
  212.   "Cross the two lists at a randomly selected point."
  213.   (if (< (length list1) 2)
  214.       (values list1 list2)
  215.       (let ((crossover-point (1+ (random (1- (length list1))))))
  216.     (list (append (firstn crossover-point list1)
  217.               (nthcdr crossover-point list2))
  218.           (append (firstn crossover-point list2)
  219.               (nthcdr crossover-point list1))))))
  220.  
  221. (defun TWO-POINT-CROSSOVER (list1 list2)
  222.   "Cross the two lists at 2 randomly selected points."
  223.   (if (< (length list1) 2)
  224.       (values list1 list2)
  225.       (let ((first-crossover-chromosomes
  226.         (one-point-crossover list1 list2)))
  227.     (one-point-crossover
  228.       (car first-crossover-chromosomes)
  229.       (cadr first-crossover-chromosomes)))))
  230.  
  231.  
  232. (defun MUTATE-BITS (mutation-rate bit-string)
  233.   "Mutate any bits in the bit string that pass the probability test"
  234.   (loop for bit in bit-string
  235.     collect (if (probability-test mutation-rate) (random 2) bit)))
  236.  
  237.  
  238. (defun TRANSFER-LIST-STRUCTURE (list1 list2)
  239.   "Put list1's structure in list2.
  240.    Both items should be lists.  NIL will not work in list2."
  241.   (rplaca list2 (car list1))
  242.   (rplacd list2 (copy-tree (cdr list1))))
  243.  
  244.  
  245. (defun PROBABILITY-TEST (prob)
  246.   "Return t with probability prob, compared to 1.0."
  247.   (<= (random 1.0) prob))
  248.  
  249.  
  250. (defun RANDOM-INTEGER (integer-1 integer-2)
  251.   "Return a random integer between (and including) the two given ones."
  252.   (+ (min integer-1 integer-2)
  253.      (random (1+ (abs (- integer-1 integer-2))))))
  254.  
  255.  
  256. (defun RANDOM-MEMBER (list)
  257.   "Return a random member of the list.  List can't be null."
  258.   (nth (random (length list)) list))
  259.  
  260. (defun random-boolean ()
  261.   "Return T or NIL, with equal probability."
  262.   (= 0 (random 2)))
  263.  
  264. (defun AVERAGE (list)
  265.   "Return floating point average of list of numbers"
  266.   (/ (apply '+ list) (float (length list))))
  267.  
  268.  
  269. (defun INTEGER-AVERAGE (int1 int2)
  270.   "Average two integers, with random rounding."
  271.   (values (funcall (nth (random 2) '(floor ceiling))
  272.            (+ int1 int2)
  273.            2)))
  274.  
  275.  
  276. (defun AVERAGE-FIRST-N-VALUES (n lists)
  277.   "Average the values in the first n lists."
  278.   (let* ((length (min n (length lists)))
  279.      (totals (apply 'mapcar (cons '+ (firstn length lists)))))
  280.     (loop for total in totals
  281.       collect (/ total (float length)))))
  282.  
  283.  
  284. (defun AVERAGE-WEIGHTS-AT-STAGE (stage history)
  285.   "Determine the average weights at the requested stage in the history"
  286.   (let* ((time (car stage))
  287.     (index  (loop for item in (car history)
  288.               for n from 0
  289.               when (equal (car item) time)
  290.               do (return n)))
  291.     (data (loop for item in history
  292.             collect (cadr (nth index item)))))
  293.     (list time (parallel-average data))))
  294.  
  295.  
  296. (defun PARALLEL-AVERAGE (lists)
  297.   "Average the parallel fields of the lists"
  298.   (loop for n from 0 to (1- (length (car lists)))
  299.     collect (average (loop for list in lists collect (nth n list)))))
  300.  
  301.  
  302. (defun MAKE-NUMBER-LIST (start end &optional (inc 1))
  303.   "Make a list of numbers from start to end"
  304.   (do ((n start (+ n inc))
  305.        (number-list nil (cons n number-list)))
  306.       ((> n end) (reverse number-list))))
  307.  
  308.  
  309. (defun CREEP-VALUE (creep-specs old-value)
  310.   "Move old-value (a number) up or down by a random amount.  Uniform dist."
  311.   (let ((new-number
  312.       (if (= (random 2) 0)
  313.           (+ old-value (random (caar creep-specs)))
  314.           (- old-value (random (caar creep-specs))))))
  315.     (if (cadar creep-specs) (round new-number) new-number)))
  316.  
  317.  
  318. (defun MAKE-RANDOM-VALUE (v-min v-max &optional (integer-value? nil))
  319.   "Produce a value between v-min and v-max.  Fix if integer is desired."
  320.   (let* ((interval (float (- v-max v-min)))
  321.      (new-number (- v-max (random interval))))
  322.     (if integer-value? (round new-number) new-number)))
  323.  
  324.  
  325. ;Reproduction of functionality of Zetalisp function, I hope.
  326. (defun FIRSTN (n list)
  327.   #-explorer
  328.   (butlast list (- (length list) n))
  329.   #+explorer
  330.   (ticl:firstn n list))
  331.  
  332.  
  333.  
  334. ;Functionality of Zetalisp function for one-dimensional arrays.
  335. #-(or explorer genera)
  336. (defun FILLARRAY (array list)
  337.   "Put the list items in the array."
  338.   (do ((n 0 (1+ n))
  339.        (array-length (array-dimension array 0))
  340.        (items list (cdr items)))
  341.       ((= n array-length))
  342.     (setf (aref array n) (car items))))
  343.  
  344. #+(or explorer genera)
  345. (import 'zl:fillarray)
  346.  
  347.  
  348. (defun LISTARRAY (array)
  349.   "One-dimensional version of zl:listarray"
  350.   (do ((n 0 (+ 1 n))
  351.        (list))
  352.       ((= n (array-dimension array 0)) (reverse list))
  353.     (setf list (cons (aref array n) list))))
  354.  
  355.  
  356. (defun SCRAMBLE-SUBLIST (list cut-point1 cut-point2)
  357.   "Scramble the sublist of the list between the two cut points and return the result.
  358. Assumption is that the cut points are in increasing numerical order."
  359.   (assert (<= cut-point1 cut-point2))
  360.   (append (firstn cut-point1 list)
  361.       (nscramble (copy-list (firstn (- cut-point2 cut-point1)
  362.                        (nthcdr cut-point1 list))))
  363.       (nthcdr cut-point2 list)))
  364.  
  365.  
  366. (defun GET-TWO-CUT-POINTS (limit)
  367.   "Get two cut points in the range from 0 to 1 below limit.  Scramble region
  368.    is truncated at the beginning and end of the range."
  369.   (if (< limit 2)
  370.       (values 0 1)
  371.       (let* ((value1 (random limit))
  372.          (amount (1+ (random limit)))
  373.          (direction (random 2)))
  374.     (if (= direction 0)
  375.         (values (max 0 (- value1 amount)) value1)
  376.         (values value1 (min (1- limit) (+ value1 amount)))))))
  377.  
  378.  
  379. (defun NSCRAMBLE (scramble-list)
  380.   "Destructive scramble of a list.  Be sure to setq the result."
  381.   (flet ((roll (list index) (if (plusp index)
  382.                 (let* ((t1 (nthcdr (1- index) list))
  383.                        (t2 (cdr t1)))
  384.                   (rplacd t1 (cdr t2))
  385.                   (rplacd t2 list))
  386.                 list)))
  387.     (when scramble-list
  388.       (let* ((list-length (length scramble-list))
  389.          (item-position (random list-length)))
  390.     (setq scramble-list (roll scramble-list item-position))
  391.     (loop for n from (1- list-length) above 1
  392.           for new-list on scramble-list
  393.           do (setq item-position (random n))
  394.           (rplacd new-list (roll (cdr new-list) item-position))))
  395.       scramble-list)))
  396.  
  397.  
  398. (defun GET-SCRAMBLE-SET (parent1 parent2 template)
  399.   "Get the ordering of items not associated with 1 on parent1 according to parent2.
  400. Template is a list of bits (0s and 1s)."
  401.   (order-by-reference (loop for bit in template
  402.                 for item in parent1
  403.                 when (= bit 0)
  404.                   collect item)
  405.               parent2))
  406.  
  407.  
  408. (defun ORDER-BY-REFERENCE (list reference-list)
  409.   "Return the items in the list in the order they occur in in the reference list"
  410.   (loop for item in reference-list
  411.     when (member item list)
  412.     collect item))
  413.  
  414.  
  415.  
  416. (defun TEMPLATE-ASSEMBLE (template list replacements)
  417.   "Return a list consisting of elements of LIST when template value is 1 and
  418. of elements of REPLACEMENTS when template value is 0."
  419.   (mapcar #'(lambda (bit x)
  420.           (if (= bit 0)
  421.           (pop replacements)
  422.           x))
  423.       template list))
  424.  
  425.  
  426. (defun INTERPOLATE-FROM-SPEC (first-y last-y last-x current-x)
  427.   "Interpolate based on current x value."
  428.   (if (listp first-y)
  429.       (do ((first-y-list first-y (cdr first-y-list))
  430.        (last-y-list last-y (cdr last-y-list))
  431.        (interpolated-values nil))
  432.       ((null first-y-list) (nreverse interpolated-values))
  433.     (setf interpolated-values
  434.           (cons (interpolate 0 (car first-y-list)
  435.                  last-x (car last-y-list) current-x)
  436.             interpolated-values)))
  437.       (interpolate 0 first-y
  438.            last-x last-y current-x)))
  439.  
  440.  
  441. (defun INTERPOLATE (x1 y1 x2 y2 x3)
  442.   "Perform linear interpolation to point 3 from points 1 and 2.
  443.   If x1 = x2, y1 is the value returned."
  444.  
  445.   (if (= x1 x2) y1
  446.       (let*  ((dx (- x2 x1))
  447.           (dy (- y2 y1))
  448.           (slope (/ dy (float dx))))
  449.     (+ y1 (* slope (- x3 x1))))))
  450.  
  451.  
  452. (defun NORMALIZE (list average-value &optional (fields (length list)))
  453.   "Multiply all fields in the list by a factor so that their average
  454.    is the desired average value."
  455.   (let* ((total (apply '+ list))
  456.      (factor (if (not (= total 0))
  457.              (/ (* (float fields) average-value) total)
  458.              1.0)))
  459.     (mapcar #'(lambda (field)
  460.         (round (* factor field)))
  461.         list)))
  462.  
  463.  
  464. (defun NORMALIZE-TOTAL (list total-value)
  465.   "Normalize the list so it totals total-value.  Avoid use if there are negative
  466. values in the list."
  467.   (let* ((total (apply '+ list))
  468.      (factor (if (< (abs total) .000000000000000001)
  469.              1 (/ (float total-value) total))))
  470.     (mapcar #'(lambda (x)
  471.         (* factor x))
  472.         list)))
  473.  
  474.  
  475.  
  476. ;;; DOUBLY LINKED LISTS
  477.  
  478. ;;; A double-linked-list is a list of doubly-linked elements.  The list
  479. ;;; maintains pointers to the first and last members.
  480.  
  481. (defclass DOUBLY-LINKED-LIST
  482.       ()
  483.   ((FIRST-MEMBER :initarg :first-member :initform nil :accessor FIRST-MEMBER)
  484.    (LAST-MEMBER :initarg :last-member :initform nil :accessor LAST-MEMBER)))
  485.  
  486.  
  487. (defclass DOUBLY-LINKED-LIST-ELEMENT
  488.       ()
  489.   ((PREDECESSOR :initarg :predecessor :initform nil :accessor PREDECESSOR)
  490.    (SUCCESSOR :initarg :successor :initform nil :accessor SUCCESSOR))
  491.   )
  492.  
  493. (defmethod MAP-OVER-ELEMENTS (function (doubly-linked-list doubly-linked-list))
  494.   (loop for element = (first-member doubly-linked-list) then (successor element)
  495.     until (null element)
  496.     collect (funcall function element)))
  497.  
  498.  
  499. (defmacro DO-ELEMENTS ((var doubly-linked-list) &body body)
  500.   `(loop for ,var = (first-member ,doubly-linked-list) then (successor ,var)
  501.      until (null ,var)
  502.      do . ,body))
  503.  
  504.  
  505. (defmethod LINK-MEMBERS ((doubly-linked-list doubly-linked-list) members)
  506.   "Link the members (list of members).  Assumption is that they are in desired order."
  507.   (link doubly-linked-list nil (car members) (cadr members))
  508.   (do ((list members (cdr list)))
  509.       ((null list))
  510.     (link doubly-linked-list (car list) (cadr list) (caddr list))))
  511.  
  512.  
  513. (defmethod LINK ((doubly-linked-list doubly-linked-list)
  514.          first-member second-member third-member)
  515.   "Link the three members in a doubly linked list"
  516.   (if first-member
  517.       (setf (successor first-member) second-member))
  518.   (when second-member
  519.     (setf (successor second-member) third-member
  520.       (predecessor second-member) first-member))
  521.   (if third-member
  522.       (setf (predecessor third-member) second-member)))
  523.  
  524.  
  525.  
  526.  
  527. ;******************************************************
  528.  
  529. ;    PERFORMANCE COLLECTION ROUTINES
  530.  
  531.  
  532. (defun AVERAGE-CADRS (list)
  533.   "Average the cadrs of parallel conses across the lists in the list"
  534.   (let* ((length (length list))
  535.      (totals (sum-cadrs list)))
  536.     (loop for x in totals
  537.       collect (list (car x) (/ (cadr x) (float length))))))
  538.  
  539.  
  540. (defun SUM-CADRS (list)
  541.   "Sum the cadrs of parallel conses across the lists in the list"
  542.   (loop for sublist in (cdr list)
  543.     with sum = (loop for item in (car list)
  544.              collect (list (car item) (cadr item)))
  545.     do (loop for item in sublist
  546.          for total in sum
  547.          do (setf (cadr total) (+ (cadr total) (cadr item))))
  548.     finally (return sum)))
  549.  
  550.  
  551. (defun EVALUATION-AT-TIME (time list)
  552.   "Return the evaluation at the time from an incremental performance list.
  553.    Assumption is that list is in reverse temporal order."
  554.   (loop for pair in list
  555.     when (>= time (car pair))
  556.     return (cadr pair)
  557.     finally (format t "~%~%NO VALUE FOR TIME ~a IN LIST ~a"
  558.             time list)))
  559.  
  560.  
  561. (defun COUNT-DECIMAL-NINES (number)
  562.   "Count the nines after the decimal.  Used in evaluations of F6 functions
  563. in the tutorial."
  564.   (loop with count = 0
  565.     for digit in
  566.         (cdr (member #\. (coerce (format nil "~a" number) 'list)))
  567.     while  (eq digit #\9)
  568.     do (incf count)
  569.     finally (return count)))
  570.  
  571.  
  572. (defmethod NINE-COUNT (population-member)
  573.   "Count the decimal nines in the member's evaluation."
  574.   (count-decimal-nines (evaluation population-member)))
  575.  
  576.  
  577. ;;;For REAL CLOS systems, this is a normal DEFMETHOD with APPEND combination.
  578. ;;;For less-than-real CLOS implementations (eg. old PCL), use AROUND methods to get
  579. ;;;the job done...
  580.  
  581. (defmacro def-append-method (name lambda-list &body body)
  582.   (unless (consp lambda-list)
  583.     (error "Looks like you have a bad lambda list for DEF-APPEND-METHOD!"))
  584.   #-:old-pcl
  585.   `(defmethod ,name append ,lambda-list . ,body)
  586.   #+:old-pcl
  587.   `(defmethod ,name :around ,lambda-list
  588.           (append (progn . ,body)
  589.               (call-next-method))))
  590.  
  591. ;;;For some reason, the Explorer didn't have APPEND method combination.
  592. ;;;Define it for them.
  593. ;;;The Explorer may define it in the future.  In this case, just comment the
  594. ;;;following out...
  595. #+ti
  596. (define-method-combination append
  597.   :operator append
  598.   :identity-with-one-argument t)
  599.  
  600. ;;; PCL Workarounds...
  601. ;;; Defgeneric isn't fully supported by PCL, so make it a noop
  602. #+:pcl
  603. (defmacro DEFGENERIC (&rest ignore) nil)
  604.